home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 20 / Cream of the Crop 20 (Terry Blount) (1996).iso / program / mcvbehtp.zip / VBEHTP30.BAS < prev    next >
BASIC Source File  |  1996-05-16  |  15KB  |  442 lines

  1. Option Explicit
  2.  
  3. Global Const VB_LNG_FRENCH = 1
  4. Global Const VB_LNG_DUTCH = 2
  5. Global Const VB_LNG_GERMAN = 3
  6. Global Const VB_LNG_ENGLISH = 4
  7. Global Const VB_LNG_ITALIAN = 5
  8. Global Const VB_LNG_SPANISH = 6
  9. Global Const VB_LNG_CATALAN = 7
  10. Global Const VB_LNG_POLISH = 8
  11.  
  12. Const MB_MESSAGE_LEFT = 0
  13.  
  14. Declare Sub cPushID Lib "mcvb3016.dll" (IDArray As Integer, ByVal nID As Integer)
  15. Declare Sub cPopID Lib "mcvb3016.dll" (IDArray As Integer, ByVal nID As Integer)
  16. Declare Sub cPopLastID Lib "mcvb3016.dll" (IDArray As Integer)
  17. Declare Function cGetID Lib "mcvb3016.dll" (IDArray As Integer, ByVal nPosition As Integer) As Integer
  18. Declare Sub cClearID Lib "mcvb3016.dll" (IDArray As Integer)
  19. Declare Sub cChangeChars Lib "mcvb3016.dll" (Txt As String, charSet As String, newCharSet As String)
  20. Declare Function cGetIni Lib "mcvb3016.dll" (ByVal AppName As String, ByVal szItem As String, ByVal szDefault As String, ByVal InitFile As String) As String
  21. Declare Function cInsertBlocks Lib "mcvb3016.dll" (Txt As String, Insert As String) As String
  22. Declare Function cLngMsgBox Lib "mcvb3016.dll" (ByVal nLanguage As Integer, ByVal Message As String, ByVal Button As Long, ByVal Title As String) As Integer
  23. Declare Function cKillFileAll Lib "mcvb3016.dll" (ByVal lpFilename As String) As Integer
  24. Declare Function cTimerClose Lib "mcvb3016.dll" (ByVal TimerHandle As Integer) As Integer
  25. Declare Function cTimerOpen Lib "mcvb3016.dll" () As Integer
  26. Declare Function cTimerRead Lib "mcvb3016.dll" (ByVal TimerHandle As Integer) As Long
  27. Declare Function cTimerStart Lib "mcvb3016.dll" (ByVal TimerHandle As Integer) As Integer
  28.  
  29. 'Don't change any variables and their value below
  30.  
  31. Const ID_ITEMS = 16
  32.  
  33. Type tagERRORHANDLERtype
  34.    ModuleName                       As String * 256
  35.    RoutineHandle                    As String * 4
  36.    RoutineName                      As String * 76
  37.    CrLf                             As String * 2
  38. End Type
  39.  
  40. Type tagTRACERtype
  41.    StartStop                        As String * 1
  42.    RoutineHandle                    As Integer
  43. End Type
  44.  
  45. Type tagPROFILERtype
  46.    ModuleName                       As String * 256
  47.    RoutineHandle                    As String * 4
  48.    RoutineName                      As String * 76
  49.    TimeCounter                      As Long
  50.    TotalCall                        As Long
  51.    TotalTime                        As Long
  52.    MinimumTime                      As Long
  53.    MaximumTime                      As Long
  54.    Dummy                            As String * 10
  55.    CrLf                             As String * 2
  56. End Type
  57.  
  58. Dim TotalRoutines                   As Integer
  59. Dim ActualTrace                     As Long
  60. Dim OldStartRoutine                 As Integer
  61. Dim OldStopRoutine                  As Integer
  62.  
  63. Dim FileTR                          As String
  64. Dim FilePF                          As String
  65.  
  66. Dim chanFileTR                      As Integer
  67. Dim chanFilePF                      As Integer
  68.  
  69. Dim FileLNG                         As String
  70.  
  71. Dim FileHND                         As String
  72.  
  73. Dim FileLOG                         As String
  74.  
  75. Dim IDArray(0 To ID_ITEMS)          As Integer
  76.  
  77. Dim Language                        As Integer
  78. Dim AutoLog                         As Integer
  79. Dim WaitingTimeForReaction          As Integer
  80. Dim DefaultButton                   As Integer
  81. Dim DisplayOnline                   As Integer
  82. Dim TraceProfile                    As Integer
  83.  
  84. Dim TotalSameHandle                 As Long
  85. Dim LastHandle                      As Integer
  86. Dim ChanHandle                      As Integer
  87. Dim OldChanHandle                   As Integer
  88.  
  89. Dim tagERRORHANDLER                 As tagERRORHANDLERtype
  90. Dim tagTRACER                       As tagTRACERtype
  91. Dim tagPROFILER                     As tagPROFILERtype
  92.  
  93. Sub mcClearID ()
  94.    Call cClearID(IDArray(0))
  95. End Sub
  96.  
  97. Function mcGetID (nPos As Integer)
  98.    mcGetID = cGetID(IDArray(0), nPos)
  99. End Function
  100.  
  101. Function mcGetLanguageID (LanguageID As Integer) As String
  102.  
  103.    Dim RetLanguage      As String
  104.  
  105.    Select Case LanguageID
  106.       Case VB_LNG_FRENCH
  107.          RetLanguage = "VFR"
  108.       Case VB_LNG_DUTCH
  109.          RetLanguage = "VNL"
  110.       Case VB_LNG_GERMAN
  111.          RetLanguage = "VDE"
  112.       Case VB_LNG_ENGLISH
  113.          RetLanguage = "VUK"
  114.       Case VB_LNG_ITALIAN
  115.          RetLanguage = "VIT"
  116.       Case VB_LNG_SPANISH
  117.          RetLanguage = "VSP"
  118.       Case VB_LNG_CATALAN
  119.          RetLanguage = "VCA"
  120.       Case VB_LNG_POLISH
  121.          RetLanguage = "VPO"
  122.       Case Else
  123.          RetLanguage = "VUK"
  124.    End Select
  125.    
  126.    If (LanguageID > 0) Then
  127.       Language = LanguageID
  128.    Else
  129.       Language = VB_LNG_ENGLISH
  130.    End If
  131.  
  132.    mcGetLanguageID = RetLanguage
  133.  
  134. End Function
  135.  
  136. Function mcIDErrorHandler (nErr As Integer) As Integer
  137.  
  138.    ' check if this a correct Error passed
  139.    If (nErr = 0) Then
  140.       'if no, resume next
  141.       mcIDErrorHandler = True
  142.       Exit Function
  143.    End If
  144.  
  145.    Dim RoutineCount     As Integer
  146.    Dim RoutineNumber    As Integer
  147.    Dim RoutineStack     As String
  148.    Dim TotalRoutines    As Integer
  149.    Dim BlankLines       As Integer
  150.    Dim Chan             As Integer
  151.    Dim StopExit         As Integer
  152.    Dim TimeOut          As Long
  153.    Dim ButtonsConfig    As Integer
  154.    Dim ErrorTitle       As String
  155.  
  156.    '  some initializations
  157.    RoutineStack = ""
  158.    TotalRoutines = 0
  159.    BlankLines = 0
  160.    StopExit = False
  161.    ButtonsConfig = 0
  162.    ErrorTitle = ""
  163.    RoutineStack = RoutineStack + mcReadText("0", "")
  164.    
  165.    ' find the next valid unused file number.
  166.    Chan = FreeFile
  167.  
  168.    ' open the file with the definition of each routines (file must be in the WINDOWS directory)
  169.    Close #Chan
  170.    Open FileHND For Random Shared As #Chan Len = Len(tagERRORHANDLER)
  171.  
  172.    ' get the stack of the routines
  173.    For RoutineCount = 0 To ID_ITEMS
  174.       ' get the number of the routine
  175.       RoutineNumber = mcGetID(RoutineCount)
  176.       ' if there a valid routine number
  177.       If (RoutineNumber > 0) Then
  178.          ' yes, read the definition of the routine
  179.          Get #Chan, RoutineNumber, tagERRORHANDLER
  180.          ' form the stack of the routines founden to display
  181.          RoutineStack = RoutineStack + Left$(tagERRORHANDLER.ModuleName + Space$(12), 14) + Chr$(9) + tagERRORHANDLER.RoutineHandle + Chr$(9) + Trim$(tagERRORHANDLER.RoutineName) + Chr$(13)
  182.          ' count the routines to display
  183.          TotalRoutines = TotalRoutines + 1
  184.       Else
  185.          ' no, exit from reading the stack
  186.          Exit For
  187.       End If
  188.    Next RoutineCount
  189.  
  190.    ' close the open file
  191.    Close #Chan
  192.  
  193.    ' check if the default button must be activated
  194.    If (DefaultButton = True) Then
  195.       ' yes, RETRY and CANCEL with RETRY is the default
  196.       ButtonsConfig = 5 Or 0
  197.    Else
  198.       ' no, RETRY and CANCEL with CANCEL is the default
  199.       ButtonsConfig = 5 Or 256
  200.       ' yes, add text for RETRY after timeout or action
  201.       RoutineStack = RoutineStack & Chr$(13) & Chr$(13) & "program will be stopped"
  202.    End If
  203.  
  204.    ' set the error title
  205.    ErrorTitle = mcReadText("1", nErr & "~" & Error$(nErr))
  206.  
  207.    ' check if one routine has been founded
  208.    If (Len(RoutineStack) > 0) Then
  209.       ' check the time out
  210.       TimeOut = WaitingTimeForReaction * (163840 Or 524288)
  211.       ' display remaining blank lines
  212.       BlankLines = (8 - TotalRoutines) - (TimeOut = 0)
  213.       For RoutineCount = 0 To BlankLines
  214.          RoutineStack = RoutineStack + Chr$(13)
  215.       Next RoutineCount
  216.       ' add some text for management
  217.       RoutineStack = RoutineStack & mcReadText("2", "")
  218.       ' check if a timeout must be used
  219.       If (TimeOut <> 0) Then
  220.          ' yes, add text depending of the default button
  221.          RoutineStack = RoutineStack & mcReadText("3", "") & " "
  222.          ' if default is RETRY then display 'continue' else 'stop'
  223.          If (DefaultButton = True) Then
  224.             RoutineStack = RoutineStack & mcReadText("4", "")
  225.          Else
  226.             RoutineStack = RoutineStack & mcReadText("5", "")
  227.          End If
  228.       End If
  229.       ' display the error message box
  230.       Stop